note
	component:   "openEHR ADL Tools"
	description: "[
					Constrainer type for instances of TERMINOLOGY_CODE. The `constraint' attribute can contain:
						* a single at-code
						* a single ac-code, representing a value-set that is defined in the archetype terminology

					If there is an assumed value for the ac-code case above, the assumed_value attribute contains a 
					single at-code, which must come from the list of at-codes defined as the internal value set for 
					the ac-code.
				 ]"
	keywords:    "archetype, terminology"
	author:      "Thomas Beale <thomas.beale@openehr.org>"
	support:     "http://www.openehr.org/issues/browse/AWB"
	copyright:   "Copyright (c) 2000- The openEHR Foundation <http://www.openEHR.org>"
	license:     "Apache 2.0 License <http://www.apache.org/licenses/LICENSE-2.0.html>"

class C_TERMINOLOGY_CODE

inherit
	C_PRIMITIVE_OBJECT
		redefine
			default_create, constraint, assumed_value, set_constraint,
			as_string, enter_subtree, exit_subtree
		end

	OPENEHR_DEFINITIONS
		export
			{NONE} all
		undefine
			out, default_create
		end

create
	make, make_example, default_create, make_identified_default

feature {NONE} -- Initialisation

	default_create
		do
			precursor {C_PRIMITIVE_OBJECT}
			create constraint.make_empty
		end

	make_example
		do
			default_create
		end

feature -- Access

	constraint: STRING
			-- single at- or ac-code

	constraint_status: detachable CONSTRAINT_STATUS
			-- Constraint status of this terminology constraint. If Void, the meaning is as follows:
			--    in a top-level archetype, equivalent to required;
			--    in a specialised (source) archetype, the meaning is to inherit the value from the corresponding node in the parent.
			-- In the case of a specialised archetype generated by flattening, the value of this field will be:
			--    Void if it was Void in the parent;
			--    otherwise, it will carry the same value as in the parent.
		note
			option: stable
		attribute
		end

	value_set_expanded: ARRAYED_LIST [STRING]
			-- effective value or value set of constraint in `constraint', either the expansion of an ac-code
			-- or else a direct at-code
		do
			if is_constraint_value_set then
				Result := value_set_terms
			else
				create Result.make (0)
				Result.compare_objects
				if not any_allowed then
					Result.extend (constraint)
				end
			end
		end

	prototype_value: TERMINOLOGY_CODE
		local
			value_set: ARRAYED_LIST [STRING]
		do
			value_set := value_set_expanded
			if not value_set.is_empty then
				create Result.make (Local_terminology_id, value_set.first)
			else
				create Result.make (Local_terminology_id, "(no-value-set-defined)")
			end
		end

	assumed_value: detachable STRING

	single_value: TERMINOLOGY_CODE
			-- single value if single-valued
		do
			create Result.make (Local_terminology_id, constraint)
		end

feature -- Status Report

	any_allowed: BOOLEAN
			-- True if any value allowed - only type is constrained
		do
			Result := constraint.is_empty
		end

	is_single_value: BOOLEAN
			-- true if constraint is a single value
		do
			Result := is_constraint_value_code
		end

	is_constraint_value_code: BOOLEAN
			-- True if this constraint is a single value code, i.e. not a value-set
		do
			Result := is_value_code (constraint)
		end

	is_constraint_value_set: BOOLEAN
			-- True if this constraint is a value set
		do
			Result := is_value_set_code (constraint)
		end

	valid_value (a_value: TERMINOLOGY_CODE): BOOLEAN
			-- see if `a_value', which must be an at-code, is one of the allowed codes in the
			-- value set(s) of this constraint
		do
			Result := any_allowed or else
				a_value.terminology_id.is_equal (Local_terminology_id) and is_valid_value_code (a_value.code_string) and
				value_set_expanded.has (a_value.code_string)
		end

	valid_assumed_value (a_value: STRING): BOOLEAN
			-- is `a_value' valid to be set as an assumed value for this object?
			-- True if `code' is an ac-code and `a_value' is an at-code. We don't check against
			-- `value_set_expanded' because it may not be constructed yet.
		do
			Result := is_valid_value_set_code (constraint) or is_valid_value_code (a_value)
		end

	effective_constraint_status: INTEGER
			-- Return the effective integer value of the constraint_status field if it exists.
			-- If it is null, return 0, i.e. required.
		do
			if attached constraint_status as cs then
				Result := cs.value
			end
		end

feature -- Comparison

	c_value_conforms_to (other: like Current): BOOLEAN
			-- True if this node expresses a value constraint that conforms to that of `other'
		local
			this_vset, other_vset: like value_set_expanded
		do
			if other.any_allowed then
				Result := True

	        -- check that constraint_status is valid. The following order hold down the specialisation
	        -- lineage, from lowest to highest: example (3) -> preferred (2) -> exensible (1) -> required (0);
	        -- numerically, specialisation child must be <= parent
	        elseif effective_constraint_status > other.effective_constraint_status then
	            Result := False

        	-- if both constraints are ac-codes, compare the value-set expansions if the
        	-- terminology constraint strengths are both `required`
    		elseif is_valid_value_set_code (constraint) and is_valid_value_set_code (other.constraint) and
    				codes_conformant (constraint, other.constraint)
    		then
				-- check if the other value-set is empty, which means there is no value-set, i.e. no constraint
				-- which means that this object's value set automatically conforms.
				other_vset := other.value_set_expanded
				if not other_vset.is_empty then
					this_vset := value_set_expanded
					Result := across this_vset as vset_csr all other_vset.has (vset_csr.item) end
				else
					Result := True
				end

			-- if this is a single at-code redefining an ac-code constraint, it must be in the ac-code
			-- value set
			elseif is_valid_value_code (constraint) and is_valid_value_set_code (other.constraint) then
				other_vset := other.value_set_expanded
				if not other_vset.is_empty then
					Result := other_vset.has (constraint)
				else
					Result := True
				end

			else
				Result := codes_conformant (constraint, other.constraint)
			end
		end

	c_value_congruent_to (other: like Current): BOOLEAN
			-- True if this node's value constraint is the same as that of `other'
		local
			this_vset, other_vset: like value_set_expanded
		do
			if is_valid_value_set_code (constraint) and is_valid_value_set_code (other.constraint) then
				this_vset := value_set_expanded
				other_vset := other.value_set_expanded
				Result := constraint.is_equal (other.constraint) and then
					this_vset.count = other_vset.count and then
						across this_vset as vset_csr all other_vset.has (vset_csr.item) end
			else
				Result := constraint.is_equal (other.constraint)
			end
		end

feature {C_TERMINOLOGY_CODE, ARCH_LIB_ARCHETYPE} -- Modification

	set_value_set_terms (a_terms: like value_set_terms)
		do
			value_set_terms := a_terms
		end

	set_constraint_status (v: INTEGER)
		require
			(create {CONSTRAINT_STATUS}).valid_value (v)
		do
			create constraint_status
			constraint_status.set_value (v)
		end

feature {AOM_151_CONVERTER} -- Modification

	set_code (a_code: STRING)
		do
			constraint := a_code
		end

	has_value_code (a_value_code: STRING): BOOLEAN
			-- True if this constraint object knows about the at-code `a_value_code'
		do
			Result := constraint.is_equal (a_value_code) or else (attached assumed_value as att_av and then att_av.is_equal (a_value_code))
		end

	replace_code (old_code, new_code: STRING)
		require
			has_value_code (old_code)
		do
			-- due to tuple constraints, there could be more than
			-- one occurrence of the old_code in the list
			if constraint.is_equal (old_code) then
				constraint := new_code
			end

			-- check the assumed code
			if attached assumed_value as att_av and then att_av.is_equal (old_code) then
				assumed_value := new_code
			end
		end

	c_congruent_to_sans_code_check (other: like Current): BOOLEAN
			-- True if this node is the same as `other'; ignore ac-codes since they are in the midst
			-- of being converted and probably don't match
		local
			this_vset, other_vset: like value_set_expanded
		do
			if is_valid_value_set_code (constraint) and is_valid_value_set_code (other.constraint) then
				this_vset := value_set_expanded
				other_vset := other.value_set_expanded
				Result := this_vset.count = other_vset.count and then
						across this_vset as vset_csr all other_vset.has (vset_csr.item) end
			else
				Result := constraint.is_equal (other.constraint)
			end
		end

feature {P_C_TERMINOLOGY_CODE} -- Modification

	set_constraint (a_constraint: STRING)
		do
			constraint := a_constraint
		end

feature -- Modification

	set_from_ui_string (a_str: STRING)
			-- make from a string (typically taken from the UI), which has the same
			-- contents as generated by the `_as_string' call
		do
			set_constraint (a_str)
		end

feature -- Output

	as_string: STRING
			-- <precursor>
		do
			create Result.make(0)
			Result.append ("[")
			Result.append (precursor)
			Result.append ("]")
		end

	as_expanded_string: STRING
			-- output in form with "local::" prepended to `value_set_expanded'
		do
			create Result.make(0)
			Result.append ("[")

			Result.append (Local_terminology_id)
			Result.append (Terminology_separator)
			if not is_valid_value_set_code (constraint) then
				Result.append (constraint)
			else
				across value_set_expanded as vset_csr loop
					if not vset_csr.is_first then
						Result.append (", ")
					end
					Result.append (vset_csr.item)
				end
			end

			if attached assumed_value as av then
				Result.append ("; " + av)
			end
			Result.append ("]")
		end

feature {NONE} -- Implementation

	constraint_as_string: STRING
			-- generate `constraint' as string
		do
			Result := constraint
		end

	value_set_terms: ARRAYED_LIST [STRING]
			-- expansion of `constraint` if carrying an ac-code
		attribute
			create Result.make (0)
			Result.compare_objects
		end

feature -- Visitor

	enter_subtree (visitor: C_VISITOR; depth: INTEGER)
			-- perform action at start of block for this node
		do
			precursor (visitor, depth)
			visitor.start_c_terminology_code (Current, depth)
		end

	exit_subtree (visitor: C_VISITOR; depth: INTEGER)
			-- perform action at end of block for this node
		do
			precursor (visitor, depth)
			visitor.end_c_terminology_code (Current, depth)
		end

end


